home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / a_utils / perl / msds-prl / prl386ld.zoo / perl.c < prev    next >
C/C++ Source or Header  |  1992-07-02  |  40KB  |  1,476 lines
  1. char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.7 $$Date: 92/06/08 14:50:39 $\nPatch level: ###\n";
  2. /*
  3.  *    Copyright (c) 1991, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of either the GNU General Public
  6.  *    License or the Artistic License, as specified in the README file.
  7.  *
  8.  * $Log:    perl.c,v $
  9.  * Revision 4.0.1.7  92/06/08  14:50:39  lwall
  10.  * patch20: PERLLIB now supports multiple directories
  11.  * patch20: running taintperl explicitly now does checks even if $< == $>
  12.  * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
  13.  * patch20: perl -P now uses location of sed determined by Configure
  14.  * patch20: form feed for formats is now specifiable via $^L
  15.  * patch20: paragraph mode now skips extra newlines automatically
  16.  * patch20: eval "1 #comment" didn't work
  17.  * patch20: couldn't require . files
  18.  * patch20: semantic compilation errors didn't abort execution
  19.  * 
  20.  * Revision 4.0.1.6  91/11/11  16:38:45  lwall
  21.  * patch19: default arg for shift was wrong after first subroutine definition
  22.  * patch19: op/regexp.t failed from missing arg to bcmp()
  23.  * 
  24.  * Revision 4.0.1.5  91/11/05  18:03:32  lwall
  25.  * patch11: random cleanup
  26.  * patch11: $0 was being truncated at times
  27.  * patch11: cppstdin now installed outside of source directory
  28.  * patch11: -P didn't allow use of #elif or #undef
  29.  * patch11: prepared for ctype implementations that don't define isascii()
  30.  * patch11: added eval {}
  31.  * patch11: eval confused by string containing null
  32.  * 
  33.  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
  34.  * patch10: perl -v printed incorrect copyright notice
  35.  * 
  36.  * Revision 4.0.1.3  91/06/07  11:40:18  lwall
  37.  * patch4: changed old $^P to $^X
  38.  * 
  39.  * Revision 4.0.1.2  91/06/07  11:26:16  lwall
  40.  * patch4: new copyright notice
  41.  * patch4: added $^P variable to control calling of perldb routines
  42.  * patch4: added $^F variable to specify maximum system fd, default 2
  43.  * patch4: debugger lost track of lines in eval
  44.  * 
  45.  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
  46.  * patch1: fixed undefined environ problem
  47.  * 
  48.  * Revision 4.0  91/03/20  01:37:44  lwall
  49.  * 4.0 baseline.
  50.  * 
  51.  */
  52.  
  53. /*SUPPRESS 560*/
  54.  
  55. #include "EXTERN.h"
  56. #include "perl.h"
  57. #include "perly.h"
  58. #include "patchlevel.h"
  59.  
  60. char *getenv();
  61.  
  62. #ifdef IAMSUID
  63. #ifndef DOSUID
  64. #define DOSUID
  65. #endif
  66. #endif
  67.  
  68. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  69. #ifdef DOSUID
  70. #undef DOSUID
  71. #endif
  72. #endif
  73.  
  74. static char* moreswitches();
  75. static void incpush();
  76. static char* cddir;
  77. static bool minus_c;
  78. static char patchlevel[6];
  79. static char *nrs = "\n";
  80. static int nrschar = '\n';      /* final char of rs, or 0777 if none */
  81. static int nrslen = 1;
  82.  
  83. main(argc,argv,env)
  84. #ifdef DJGPP
  85. int argc;
  86. char **argv;
  87. #else
  88. register int argc;
  89. register char **argv;
  90. #endif /* DJGPP */
  91. register char **env;
  92. {
  93.     register STR *str;
  94.     register char *s;
  95.     char *scriptname;
  96.     char *getenv();
  97.     bool dosearch = FALSE;
  98. #ifdef DOSUID
  99.     char *validarg = "";
  100. #endif
  101.  
  102. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  103. #ifdef IAMSUID
  104. #undef IAMSUID
  105.     fatal("suidperl is no longer needed since the kernel can now execute\n\
  106. setuid perl scripts securely.\n");
  107. #endif
  108. #endif
  109.  
  110. /*
  111.  * this is the args globbing in libglob.a - H.Doi
  112.  */
  113. #ifdef MSDOS
  114.   {
  115.     char **glob_filename();
  116.     int globargv();
  117.  
  118.     if (globargv(&argc, &argv, glob_filename)) {
  119.       fprintf(stderr, "globargv failed!\n");
  120.     }
  121.   }
  122. #endif /* MSDOS */
  123.  
  124.     origargv = argv;
  125.     origargc = argc;
  126.     origenviron = environ;
  127.     uid = (int)getuid();
  128.     euid = (int)geteuid();
  129.     gid = (int)getgid();
  130.     egid = (int)getegid();
  131.     sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
  132. #ifdef MSDOS
  133.     /*
  134.      * There is no way we can refer to them from Perl so close them to save
  135.      * space.  The other alternative would be to provide STDAUX and STDPRN
  136.      * filehandles.
  137.      */
  138. #ifndef DJGPP
  139.     (void)fclose(stdaux);
  140.     (void)fclose(stdprn);
  141. #endif /* !DJGPP */
  142. #endif
  143.     if (do_undump) {
  144.     origfilename = savestr(argv[0]);
  145.     do_undump = 0;
  146.     loop_ptr = -1;        /* start label stack again */
  147.     goto just_doit;
  148.     }
  149. #ifdef TAINT
  150. #ifndef DOSUID
  151.     if (uid == euid && gid == egid)
  152.     taintanyway == TRUE;        /* running taintperl explicitly */
  153. #endif
  154. #endif
  155.     (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
  156.     linestr = Str_new(65,80);
  157.     str_nset(linestr,"",0);
  158.     str = str_make("",0);        /* first used for -I flags */
  159.     curstash = defstash = hnew(0);
  160.     curstname = str_make("main",4);
  161.     stab_xhash(stabent("_main",TRUE)) = defstash;
  162.     defstash->tbl_name = "main";
  163.     incstab = hadd(aadd(stabent("INC",TRUE)));
  164.     incstab->str_pok |= SP_MULTI;
  165.     for (argc--,argv++; argc > 0; argc--,argv++) {
  166.     if (argv[0][0] != '-' || !argv[0][1])
  167.         break;
  168. #ifdef DOSUID
  169.     if (*validarg)
  170.     validarg = " PHOOEY ";
  171.     else
  172.     validarg = argv[0];
  173. #endif
  174.     s = argv[0]+1;
  175.       reswitch:
  176.     switch (*s) {
  177.     case '0':
  178.     case 'a':
  179.     case 'c':
  180.     case 'd':
  181.     case 'D':
  182.     case 'i':
  183.     case 'l':
  184.     case 'n':
  185.     case 'p':
  186.     case 'u':
  187.     case 'U':
  188.     case 'v':
  189.     case 'w':
  190.         if (s = moreswitches(s))
  191.         goto reswitch;
  192.         break;
  193.  
  194.     case 'e':
  195. #ifdef TAINT
  196.         if (euid != uid || egid != gid)
  197.         fatal("No -e allowed in setuid scripts");
  198. #endif
  199.         if (!e_fp) {
  200.             e_tmpname = savestr(TMPPATH);
  201.         (void)mktemp(e_tmpname);
  202.         if (!*e_tmpname)
  203.             fatal("Can't mktemp()");
  204.         e_fp = fopen(e_tmpname,"w");
  205.         if (!e_fp)
  206.             fatal("Cannot open temporary file");
  207.         }
  208.         if (argv[1]) {
  209.         fputs(argv[1],e_fp);
  210.         argc--,argv++;
  211.         }
  212.         (void)putc('\n', e_fp);
  213.         break;
  214.     case 'I':
  215. #ifdef TAINT
  216.         if (euid != uid || egid != gid)
  217.         fatal("No -I allowed in setuid scripts");
  218. #endif
  219.         str_cat(str,"-");
  220.         str_cat(str,s);
  221.         str_cat(str," ");
  222.         if (*++s) {
  223.         (void)apush(stab_array(incstab),str_make(s,0));
  224.         }
  225.         else if (argv[1]) {
  226.         (void)apush(stab_array(incstab),str_make(argv[1],0));
  227.         str_cat(str,argv[1]);
  228.         argc--,argv++;
  229.         str_cat(str," ");
  230.         }
  231.         break;
  232.     case 'P':
  233. #ifdef TAINT
  234.         if (euid != uid || egid != gid)
  235.         fatal("No -P allowed in setuid scripts");
  236. #endif
  237.         preprocess = TRUE;
  238.         s++;
  239.         goto reswitch;
  240.     case 's':
  241. #ifdef TAINT
  242.         if (euid != uid || egid != gid)
  243.         fatal("No -s allowed in setuid scripts");
  244. #endif
  245.         doswitches = TRUE;
  246.         s++;
  247.         goto reswitch;
  248.     case 'S':
  249. #ifdef TAINT
  250.         if (euid != uid || egid != gid)
  251.         fatal("No -S allowed in setuid scripts");
  252. #endif
  253.         dosearch = TRUE;
  254.         s++;
  255.         goto reswitch;
  256.     case 'x':
  257.         doextract = TRUE;
  258.         s++;
  259.         if (*s)
  260.         cddir = savestr(s);
  261.         break;
  262.     case '-':
  263.         argc--,argv++;
  264.         goto switch_end;
  265.     case 0:
  266.         break;
  267.     default:
  268.         fatal("Unrecognized switch: -%s",s);
  269.     }
  270.     }
  271.   switch_end:
  272.     scriptname = argv[0];
  273.     if (e_fp) {
  274.     if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
  275.         fatal("Can't write to temp file for -e: %s", strerror(errno));
  276.     argc++,argv--;
  277.     scriptname = e_tmpname;
  278.     }
  279.  
  280. #ifdef DOSISH
  281. #define PERLLIB_SEP ';'
  282. #else
  283. #define PERLLIB_SEP ':'
  284. #endif
  285. #ifndef TAINT        /* Can't allow arbitrary PERLLIB in setuid script */
  286.     incpush(getenv("PERLLIB"));
  287. #endif /* TAINT */
  288.  
  289. #ifndef PRIVLIB
  290. #define PRIVLIB "/usr/local/lib/perl"
  291. #endif
  292.     incpush(PRIVLIB);
  293.     (void)apush(stab_array(incstab),str_make(".",1));
  294.  
  295.     str_set(&str_no,No);
  296.     str_set(&str_yes,Yes);
  297.  
  298.     /* open script */
  299.  
  300.     if (scriptname == Nullch)
  301. #ifdef MSDOS
  302.     {
  303.     if ( isatty(fileno(stdin)) )
  304.       moreswitches("v");
  305.     scriptname = "-";
  306.     }
  307. #else
  308.     scriptname = "-";
  309. #endif
  310.     if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
  311.     char *xfound = Nullch, *xfailed = Nullch;
  312.     int len;
  313.  
  314.     bufend = s + strlen(s);
  315.     while (*s) {
  316. #ifndef DOSISH
  317.         s = cpytill(tokenbuf,s,bufend,':',&len);
  318. #else
  319. #ifdef atarist
  320.         for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
  321.         tokenbuf[len] = '\0';
  322. #else
  323.         for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
  324.         tokenbuf[len] = '\0';
  325. #endif
  326. #endif
  327.         if (*s)
  328.         s++;
  329. #ifndef DOSISH
  330.         if (len && tokenbuf[len-1] != '/')
  331. #else
  332. #ifdef atarist
  333.         if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
  334. #else
  335.         if (len && tokenbuf[len-1] != '\\')
  336. #endif
  337. #endif
  338.         (void)strcat(tokenbuf+len,"/");
  339.         (void)strcat(tokenbuf+len,scriptname);
  340. #ifdef DEBUGGING
  341.         if (debug & 1)
  342.         fprintf(stderr,"Looking for %s\n",tokenbuf);
  343. #endif
  344.         if (stat(tokenbuf,&statbuf) < 0)        /* not there? */
  345.         continue;
  346.         if (S_ISREG(statbuf.st_mode)
  347.          && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
  348.         xfound = tokenbuf;              /* bingo! */
  349.         break;
  350.         }
  351.         if (!xfailed)
  352.         xfailed = savestr(tokenbuf);
  353.     }
  354.     if (!xfound)
  355.         fatal("Can't execute %s", xfailed ? xfailed : scriptname );
  356.     if (xfailed)
  357.         Safefree(xfailed);
  358.     scriptname = savestr(xfound);
  359.     }
  360.  
  361.     fdpid = anew(Nullstab);    /* for remembering popen pids by fd */
  362.     pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
  363.  
  364.     origfilename = savestr(scriptname);
  365.     curcmd->c_filestab = fstab(origfilename);
  366.     if (strEQ(origfilename,"-"))
  367.     scriptname = "";
  368.     if (preprocess) {
  369.     char *cpp = CPPSTDIN;
  370.  
  371.     if (strEQ(cpp,"cppstdin"))
  372.         sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
  373.     else
  374.         sprintf(tokenbuf, "%s", cpp);
  375.     str_cat(str,"-I");
  376.     str_cat(str,PRIVLIB);
  377. #ifdef MSDOS
  378.     (void)sprintf(buf, "\
  379. sed %s -e \"/^[^#]/b\" \
  380.  -e \"/^#[     ]*include[     ]/b\" \
  381.  -e \"/^#[     ]*define[     ]/b\" \
  382.  -e \"/^#[     ]*if[     ]/b\" \
  383.  -e \"/^#[     ]*ifdef[     ]/b\" \
  384.  -e \"/^#[     ]*ifndef[     ]/b\" \
  385.  -e \"/^#[     ]*else/b\" \
  386.  -e \"/^#[     ]*elif[     ]/b\" \
  387.  -e \"/^#[     ]*undef[     ]/b\" \
  388.  -e \"/^#[     ]*endif/b\" \
  389.  -e \"s/^#.*//\" \
  390.  %s | %s -C %s %s",
  391.       (doextract ? "-e \"1,/^#/d\n\"" : ""),
  392. #else
  393.     (void)sprintf(buf, "\
  394. %s %s -e '/^[^#]/b' \
  395.  -e '/^#[     ]*include[     ]/b' \
  396.  -e '/^#[     ]*define[     ]/b' \
  397.  -e '/^#[     ]*if[     ]/b' \
  398.  -e '/^#[     ]*ifdef[     ]/b' \
  399.  -e '/^#[     ]*ifndef[     ]/b' \
  400.  -e '/^#[     ]*else/b' \
  401.  -e '/^#[     ]*elif[     ]/b' \
  402.  -e '/^#[     ]*undef[     ]/b' \
  403.  -e '/^#[     ]*endif/b' \
  404.  -e 's/^[     ]*#.*//' \
  405.  %s | %s -C %s %s",
  406. #ifdef LOC_SED
  407.       LOC_SED,
  408. #else
  409.       "sed",
  410. #endif
  411.       (doextract ? "-e '1,/^#/d\n'" : ""),
  412. #endif
  413.       scriptname, tokenbuf, str_get(str), CPPMINUS);
  414. #ifdef DEBUGGING
  415.     if (debug & 64) {
  416.         fputs(buf,stderr);
  417.         fputs("\n",stderr);
  418.     }
  419. #endif
  420.     doextract = FALSE;
  421. #ifdef IAMSUID                /* actually, this is caught earlier */
  422.     if (euid != uid && !euid) {    /* if running suidperl */
  423. #ifdef HAS_SETEUID
  424.         (void)seteuid(uid);        /* musn't stay setuid root */
  425. #else
  426. #ifdef HAS_SETREUID
  427.         (void)setreuid(-1, uid);
  428. #else
  429.         setuid(uid);
  430. #endif
  431. #endif
  432.         if (geteuid() != uid)
  433.         fatal("Can't do seteuid!\n");
  434.     }
  435. #endif /* IAMSUID */
  436.     rsfp = mypopen(buf,"r");
  437.     }
  438.     else if (!*scriptname) {
  439. #ifdef TAINT
  440.     if (euid != uid || egid != gid)
  441.         fatal("Can't take set-id script from stdin");
  442. #endif
  443.     rsfp = stdin;
  444.     }
  445.     else
  446.     rsfp = fopen(scriptname,"r");
  447.     if ((FILE*)rsfp == Nullfp) {
  448. #ifdef DOSUID
  449. #ifndef IAMSUID        /* in case script is not readable before setuid */
  450.     if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
  451.       statbuf.st_mode & (S_ISUID|S_ISGID)) {
  452.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  453. #ifndef DJGPP
  454.         execv(buf, origargv);    /* try again */
  455. #endif /* !DJGPP */
  456.         fatal("Can't do setuid\n");
  457.     }
  458. #endif
  459. #endif
  460.     fatal("Can't open perl script \"%s\": %s\n",
  461.       stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
  462.     }
  463.     str_free(str);        /* free -I directories */
  464.     str = Nullstr;
  465.  
  466.     /* do we need to emulate setuid on scripts? */
  467.  
  468.     /* This code is for those BSD systems that have setuid #! scripts disabled
  469.      * in the kernel because of a security problem.  Merely defining DOSUID
  470.      * in perl will not fix that problem, but if you have disabled setuid
  471.      * scripts in the kernel, this will attempt to emulate setuid and setgid
  472.      * on scripts that have those now-otherwise-useless bits set.  The setuid
  473.      * root version must be called suidperl or sperlN.NNN.  If regular perl
  474.      * discovers that it has opened a setuid script, it calls suidperl with
  475.      * the same argv that it had.  If suidperl finds that the script it has
  476.      * just opened is NOT setuid root, it sets the effective uid back to the
  477.      * uid.  We don't just make perl setuid root because that loses the
  478.      * effective uid we had before invoking perl, if it was different from the
  479.      * uid.
  480.      *
  481.      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
  482.      * be defined in suidperl only.  suidperl must be setuid root.  The
  483.      * Configure script will set this up for you if you want it.
  484.      *
  485.      * There is also the possibility of have a script which is running
  486.      * set-id due to a C wrapper.  We want to do the TAINT checks
  487.      * on these set-id scripts, but don't want to have the overhead of
  488.      * them in normal perl, and can't use suidperl because it will lose
  489.      * the effective uid info, so we have an additional non-setuid root
  490.      * version called taintperl or tperlN.NNN that just does the TAINT checks.
  491.      */
  492.  
  493. #ifdef DOSUID
  494.     if (fstat(fileno(rsfp),&statbuf) < 0)    /* normal stat is insecure */
  495.     fatal("Can't stat script \"%s\"",origfilename);
  496.     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
  497.     int len;
  498.  
  499. #ifdef IAMSUID
  500. #ifndef HAS_SETREUID
  501.     /* On this access check to make sure the directories are readable,
  502.      * there is actually a small window that the user could use to make
  503.      * filename point to an accessible directory.  So there is a faint
  504.      * chance that someone could execute a setuid script down in a
  505.      * non-accessible directory.  I don't know what to do about that.
  506.      * But I don't think it's too important.  The manual lies when
  507.      * it says access() is useful in setuid programs.
  508.      */
  509.     if (access(stab_val(curcmd->c_filestab)->str_ptr,1))    /*double check*/
  510.         fatal("Permission denied");
  511. #else
  512.     /* If we can swap euid and uid, then we can determine access rights
  513.      * with a simple stat of the file, and then compare device and
  514.      * inode to make sure we did stat() on the same file we opened.
  515.      * Then we just have to make sure he or she can execute it.
  516.      */
  517.     {
  518.         struct stat tmpstatbuf;
  519.  
  520.         if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
  521.         fatal("Can't swap uid and euid");    /* really paranoid */
  522.         if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
  523.         fatal("Permission denied");    /* testing full pathname here */
  524.         if (tmpstatbuf.st_dev != statbuf.st_dev ||
  525.         tmpstatbuf.st_ino != statbuf.st_ino) {
  526.         (void)fclose(rsfp);
  527.         if (rsfp = mypopen("/bin/mail root","w")) {    /* heh, heh */
  528.             fprintf(rsfp,
  529. "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
  530. (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
  531.             uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
  532.             statbuf.st_dev, statbuf.st_ino,
  533.             stab_val(curcmd->c_filestab)->str_ptr,
  534.             statbuf.st_uid, statbuf.st_gid);
  535.             (void)mypclose(rsfp);
  536.         }
  537.         fatal("Permission denied\n");
  538.         }
  539.         if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
  540.         fatal("Can't reswap uid and euid");
  541.         if (!cando(S_IXUSR,FALSE,&statbuf))        /* can real uid exec? */
  542.         fatal("Permission denied\n");
  543.     }
  544. #endif /* HAS_SETREUID */
  545. #endif /* IAMSUID */
  546.  
  547.     if (!S_ISREG(statbuf.st_mode))
  548.         fatal("Permission denied");
  549.     if (statbuf.st_mode & S_IWOTH)
  550.         fatal("Setuid/gid script is writable by world");
  551.     doswitches = FALSE;        /* -s is insecure in suid */
  552.     curcmd->c_line++;
  553.     if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
  554.       strnNE(tokenbuf,"#!",2) )    /* required even on Sys V */
  555.         fatal("No #! line");
  556.     s = tokenbuf+2;
  557.     if (*s == ' ') s++;
  558.     while (!isSPACE(*s)) s++;
  559.     if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
  560.         fatal("Not a perl script");
  561.     while (*s == ' ' || *s == '\t') s++;
  562.     /*
  563.      * #! arg must be what we saw above.  They can invoke it by
  564.      * mentioning suidperl explicitly, but they may not add any strange
  565.      * arguments beyond what #! says if they do invoke suidperl that way.
  566.      */
  567.     len = strlen(validarg);
  568.     if (strEQ(validarg," PHOOEY ") ||
  569.         strnNE(s,validarg,len) || !isSPACE(s[len]))
  570.         fatal("Args must match #! line");
  571.  
  572. #ifndef IAMSUID
  573.     if (euid != uid && (statbuf.st_mode & S_ISUID) &&
  574.         euid == statbuf.st_uid)
  575.         if (!do_undump)
  576.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  577. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  578. #endif /* IAMSUID */
  579.  
  580.     if (euid) {    /* oops, we're not the setuid root perl */
  581.         (void)fclose(rsfp);
  582. #ifndef IAMSUID
  583.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  584. #ifndef DJGPP
  585.         execv(buf, origargv);    /* try again */
  586. #endif /* !DJGPP */
  587. #endif
  588.         fatal("Can't do setuid\n");
  589.     }
  590.  
  591.     if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
  592. #ifdef HAS_SETEGID
  593.         (void)setegid(statbuf.st_gid);
  594. #else
  595. #ifdef HAS_SETREGID
  596.         (void)setregid((GIDTYPE)-1,statbuf.st_gid);
  597. #else
  598.         setgid(statbuf.st_gid);
  599. #endif
  600. #endif
  601.         if (getegid() != statbuf.st_gid)
  602.         fatal("Can't do setegid!\n");
  603.     }
  604.     if (statbuf.st_mode & S_ISUID) {
  605.         if (statbuf.st_uid != euid)
  606. #ifdef HAS_SETEUID
  607.         (void)seteuid(statbuf.st_uid);    /* all that for this */
  608. #else
  609. #ifdef HAS_SETREUID
  610.         (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
  611. #else
  612.         setuid(statbuf.st_uid);
  613. #endif
  614. #endif
  615.         if (geteuid() != statbuf.st_uid)
  616.         fatal("Can't do seteuid!\n");
  617.     }
  618.     else if (uid) {            /* oops, mustn't run as root */
  619. #ifdef HAS_SETEUID
  620.         (void)seteuid((UIDTYPE)uid);
  621. #else
  622. #ifdef HAS_SETREUID
  623.         (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
  624. #else
  625.         setuid((UIDTYPE)uid);
  626. #endif
  627. #endif
  628.         if (geteuid() != uid)
  629.         fatal("Can't do seteuid!\n");
  630.     }
  631.     uid = (int)getuid();
  632.     euid = (int)geteuid();
  633.     gid = (int)getgid();
  634.     egid = (int)getegid();
  635.     if (!cando(S_IXUSR,TRUE,&statbuf))
  636.         fatal("Permission denied\n");    /* they can't do this */
  637.     }
  638. #ifdef IAMSUID
  639.     else if (preprocess)
  640.     fatal("-P not allowed for setuid/setgid script\n");
  641.     else
  642.     fatal("Script is not setuid/setgid in suidperl\n");
  643. #else
  644. #ifndef TAINT        /* we aren't taintperl or suidperl */
  645.     /* script has a wrapper--can't run suidperl or we lose euid */
  646.     else if (euid != uid || egid != gid) {
  647.     (void)fclose(rsfp);
  648.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  649. #ifndef DJGPP
  650.     execv(buf, origargv);    /* try again */
  651. #endif /* !DJGPP */
  652.     fatal("Can't run setuid script with taint checks");
  653.     }
  654. #endif /* TAINT */
  655. #endif /* IAMSUID */
  656. #else /* !DOSUID */
  657. #ifndef TAINT        /* we aren't taintperl or suidperl */
  658.     if (euid != uid || egid != gid) {    /* (suidperl doesn't exist, in fact) */
  659. #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
  660.     fstat(fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
  661.     if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
  662.         ||
  663.         (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
  664.        )
  665.         if (!do_undump)
  666.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  667. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  668. #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
  669.     /* not set-id, must be wrapped */
  670.     (void)fclose(rsfp);
  671.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  672. #ifndef DJGPP
  673.     execv(buf, origargv);    /* try again */
  674. #endif /* !DJGPP */
  675.     fatal("Can't run setuid script with taint checks");
  676.     }
  677. #endif /* TAINT */
  678. #endif /* DOSUID */
  679.  
  680. #if !defined(IAMSUID) && !defined(TAINT)
  681.  
  682.     /* skip forward in input to the real script? */
  683.  
  684.     while (doextract) {
  685.     if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
  686.         fatal("No Perl script found in input\n");
  687.     if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
  688.         ungetc('\n',rsfp);        /* to keep line count right */
  689.         doextract = FALSE;
  690.         if (s = instr(s,"perl -")) {
  691.         s += 6;
  692.         /*SUPPRESS 530*/
  693.         while (s = moreswitches(s)) ;
  694.         }
  695.         if (cddir && chdir(cddir) < 0)
  696.         fatal("Can't chdir to %s",cddir);
  697.     }
  698.     }
  699. #endif /* !defined(IAMSUID) && !defined(TAINT) */
  700.  
  701.     defstab = stabent("_",TRUE);
  702.  
  703.     subname = str_make("main",4);
  704.     if (perldb) {
  705.     debstash = hnew(0);
  706.     stab_xhash(stabent("_DB",TRUE)) = debstash;
  707.     curstash = debstash;
  708.     dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
  709.     tmpstab->str_pok |= SP_MULTI;
  710.     dbargs->ary_flags = 0;
  711.     DBstab = stabent("DB",TRUE);
  712.     DBstab->str_pok |= SP_MULTI;
  713.     DBline = stabent("dbline",TRUE);
  714.     DBline->str_pok |= SP_MULTI;
  715.     DBsub = hadd(tmpstab = stabent("sub",TRUE));
  716.     tmpstab->str_pok |= SP_MULTI;
  717.     DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
  718.     tmpstab->str_pok |= SP_MULTI;
  719.     DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
  720.     tmpstab->str_pok |= SP_MULTI;
  721.     DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
  722.     tmpstab->str_pok |= SP_MULTI;
  723.     curstash = defstash;
  724.     }
  725.  
  726.     /* init tokener */
  727.  
  728.     bufend = bufptr = str_get(linestr);
  729.  
  730.     savestack = anew(Nullstab);        /* for saving non-local values */
  731.     stack = anew(Nullstab);        /* for saving non-local values */
  732.     stack->ary_flags = 0;        /* not a real array */
  733.     afill(stack,63); afill(stack,-1);    /* preextend stack */
  734.     afill(savestack,63); afill(savestack,-1);
  735.  
  736.     /* now parse the script */
  737.  
  738.     error_count = 0;
  739.     if (yyparse() || error_count) {
  740.     if (minus_c)
  741.         fatal("%s had compilation errors.\n", origfilename);
  742.     else {
  743.         fatal("Execution of %s aborted due to compilation errors.\n",
  744.         origfilename);
  745.     }
  746.     }
  747.  
  748.     New(50,loop_stack,128,struct loop);
  749. #ifdef DEBUGGING
  750.     if (debug) {
  751.     New(51,debname,128,char);
  752.     New(52,debdelim,128,char);
  753.     }
  754. #endif
  755.     curstash = defstash;
  756.  
  757.     preprocess = FALSE;
  758.     if (e_fp) {
  759.     e_fp = Nullfp;
  760.     (void)UNLINK(e_tmpname);
  761.     }
  762.  
  763.     /* initialize everything that won't change if we undump */
  764.  
  765.     if (sigstab = stabent("SIG",allstabs)) {
  766.     sigstab->str_pok |= SP_MULTI;
  767.     (void)hadd(sigstab);
  768.     }
  769.  
  770.     magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
  771.     userinit();        /* in case linked C routines want magical variables */
  772.  
  773.     amperstab = stabent("&",allstabs);
  774.     leftstab = stabent("`",allstabs);
  775.     rightstab = stabent("'",allstabs);
  776.     sawampersand = (amperstab || leftstab || rightstab);
  777.     if (tmpstab = stabent(":",allstabs))
  778.     str_set(stab_val(tmpstab),chopset);
  779.     if (tmpstab = stabent("\024",allstabs))
  780.     time(&basetime);
  781.  
  782.     /* these aren't necessarily magical */
  783.     if (tmpstab = stabent("\014",allstabs)) {
  784.     str_set(stab_val(tmpstab),"\f");
  785.     formfeed = stab_val(tmpstab);
  786.     }
  787.     if (tmpstab = stabent(";",allstabs))
  788.     str_set(STAB_STR(tmpstab),"\034");
  789.     if (tmpstab = stabent("]",allstabs)) {
  790.     str = STAB_STR(tmpstab);
  791.     str_set(str,rcsid);
  792.     str->str_u.str_nval = atof(patchlevel);
  793.     str->str_nok = 1;
  794.     }
  795.     str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
  796.  
  797.     stdinstab = stabent("STDIN",TRUE);
  798.     stdinstab->str_pok |= SP_MULTI;
  799.     if (!stab_io(stdinstab))
  800.     stab_io(stdinstab) = stio_new();
  801.     stab_io(stdinstab)->ifp = stdin;
  802.     tmpstab = stabent("stdin",TRUE);
  803.     stab_io(tmpstab) = stab_io(stdinstab);
  804.     tmpstab->str_pok |= SP_MULTI;
  805.  
  806.     tmpstab = stabent("STDOUT",TRUE);
  807.     tmpstab->str_pok |= SP_MULTI;
  808.     if (!stab_io(tmpstab))
  809.     stab_io(tmpstab) = stio_new();
  810.     stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
  811.     defoutstab = tmpstab;
  812.     tmpstab = stabent("stdout",TRUE);
  813.     stab_io(tmpstab) = stab_io(defoutstab);
  814.     tmpstab->str_pok |= SP_MULTI;
  815.  
  816.     curoutstab = stabent("STDERR",TRUE);
  817.     curoutstab->str_pok |= SP_MULTI;
  818.     if (!stab_io(curoutstab))
  819.     stab_io(curoutstab) = stio_new();
  820.     stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
  821.     tmpstab = stabent("stderr",TRUE);
  822.     stab_io(tmpstab) = stab_io(curoutstab);
  823.     tmpstab->str_pok |= SP_MULTI;
  824.     curoutstab = defoutstab;        /* switch back to STDOUT */
  825.  
  826.     statname = Str_new(66,0);        /* last filename we did stat on */
  827.  
  828.     /* now that script is parsed, we can modify record separator */
  829.  
  830.     rs = nrs;
  831.     rslen = nrslen;
  832.     rschar = nrschar;
  833.     rspara = (nrslen == 2);
  834.     str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
  835.  
  836.     if (do_undump)
  837.     my_unexec();
  838.  
  839.   just_doit:        /* come here if running an undumped a.out */
  840.     argc--,argv++;    /* skip name of script */
  841.     if (doswitches) {
  842.     for (; argc > 0 && **argv == '-'; argc--,argv++) {
  843.         if (argv[0][1] == '-') {
  844.         argc--,argv++;
  845.         break;
  846.         }
  847.         if (s = index(argv[0], '=')) {
  848.         *s++ = '\0';
  849.         str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
  850.         }
  851.         else
  852.         str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
  853.     }
  854.     }
  855. #ifdef TAINT
  856.     tainted = 1;
  857. #endif
  858.     if (tmpstab = stabent("0",allstabs)) {
  859.     str_set(stab_val(tmpstab),origfilename);
  860.     magicname("0", Nullch, 0);
  861.     }
  862.     if (tmpstab = stabent("\030",allstabs))
  863.     str_set(stab_val(tmpstab),origargv[0]);
  864.     if (argvstab = stabent("ARGV",allstabs)) {
  865.     argvstab->str_pok |= SP_MULTI;
  866.     (void)aadd(argvstab);
  867.     aclear(stab_array(argvstab));
  868.     for (; argc > 0; argc--,argv++) {
  869.         (void)apush(stab_array(argvstab),str_make(argv[0],0));
  870.     }
  871.     }
  872. #ifdef TAINT
  873.     (void) stabent("ENV",TRUE);        /* must test PATH and IFS */
  874. #endif
  875.     if (envstab = stabent("ENV",allstabs)) {
  876.     envstab->str_pok |= SP_MULTI;
  877.     (void)hadd(envstab);
  878.     hclear(stab_hash(envstab), FALSE);
  879.     if (env != environ)
  880.         environ[0] = Nullch;
  881.     for (; *env; env++) {
  882.         if (!(s = index(*env,'=')))
  883.         continue;
  884.         *s++ = '\0';
  885.         str = str_make(s--,0);
  886.         str_magic(str, envstab, 'E', *env, s - *env);
  887.         (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
  888.         *s = '=';
  889.     }
  890.     }
  891. #ifdef TAINT
  892.     tainted = 0;
  893. #endif
  894.     if (tmpstab = stabent("$",allstabs))
  895.     str_numset(STAB_STR(tmpstab),(double)getpid());
  896.  
  897.     if (dowarn) {
  898.     stab_check('A','Z');
  899.     stab_check('a','z');
  900.     }
  901.  
  902.     if (setjmp(top_env))    /* sets goto_targ on longjump */
  903.     loop_ptr = -1;        /* start label stack again */
  904.  
  905. #ifdef DEBUGGING
  906.     if (debug & 1024)
  907.     dump_all();
  908.     if (debug)
  909.     fprintf(stderr,"\nEXECUTING...\n\n");
  910. #endif
  911.  
  912.     if (minus_c) {
  913.     fprintf(stderr,"%s syntax OK\n", origfilename);
  914.     exit(0);
  915.     }
  916.  
  917.     /* do it */
  918.  
  919.     (void) cmd_exec(main_root,G_SCALAR,-1);
  920.  
  921.     if (goto_targ)
  922.     fatal("Can't find label \"%s\"--aborting",goto_targ);
  923.     exit(0);
  924.     /* NOTREACHED */
  925. }
  926.  
  927. void
  928. magicalize(list)
  929. register char *list;
  930. {
  931.     char sym[2];
  932.  
  933.     sym[1] = '\0';
  934.     while (*sym = *list++)
  935.     magicname(sym, Nullch, 0);
  936. }
  937.  
  938. void
  939. magicname(sym,name,namlen)
  940. char *sym;
  941. char *name;
  942. int namlen;
  943. {
  944.     register STAB *stab;
  945.  
  946.     if (stab = stabent(sym,allstabs)) {
  947.     stab_flags(stab) = SF_VMAGIC;
  948.     str_magic(stab_val(stab), stab, 0, name, namlen);
  949.     }
  950. }
  951.  
  952. static void
  953. incpush(p)
  954. char *p;
  955. {
  956.     char *s;
  957.  
  958.     if (!p)
  959.     return;
  960.  
  961.     /* Break at all separators */
  962.     while (*p) {
  963.     /* First, skip any consecutive separators */
  964.     while ( *p == PERLLIB_SEP ) {
  965.         /* Uncomment the next line for PATH semantics */
  966.         /* (void)apush(stab_array(incstab), str_make(".", 1)); */
  967.         p++;
  968.     }
  969.     if ( (s = index(p, PERLLIB_SEP)) != Nullch ) {
  970.         (void)apush(stab_array(incstab), str_make(p, (int)(s - p)));
  971.         p = s + 1;
  972.     } else {
  973.         (void)apush(stab_array(incstab), str_make(p, 0));
  974.         break;
  975.     }
  976.     }
  977. }
  978.  
  979. void
  980. savelines(array, str)
  981. ARRAY *array;
  982. STR *str;
  983. {
  984.     register char *s = str->str_ptr;
  985.     register char *send = str->str_ptr + str->str_cur;
  986.     register char *t;
  987.     register int line = 1;
  988.  
  989.     while (s && s < send) {
  990.     STR *tmpstr = Str_new(85,0);
  991.  
  992.     t = index(s, '\n');
  993.     if (t)
  994.         t++;
  995.     else
  996.         t = send;
  997.  
  998.     str_nset(tmpstr, s, t - s);
  999.     astore(array, line++, tmpstr);
  1000.     s = t;
  1001.     }
  1002. }
  1003.  
  1004. /* this routine is in perl.c by virtue of being sort of an alternate main() */
  1005.  
  1006. int
  1007. do_eval(str,optype,stash,savecmd,gimme,arglast)
  1008. STR *str;
  1009. int optype;
  1010. HASH *stash;
  1011. int savecmd;
  1012. int gimme;
  1013. int *arglast;
  1014. {
  1015.     STR **st = stack->ary_array;
  1016.     int retval;
  1017.     CMD *myroot = Nullcmd;
  1018.     ARRAY *ar;
  1019.     int i;
  1020.     CMD * VOLATILE oldcurcmd = curcmd;
  1021.     VOLATILE int oldtmps_base = tmps_base;
  1022.     VOLATILE int oldsave = savestack->ary_fill;
  1023.     VOLATILE int oldperldb = perldb;
  1024.     SPAT * VOLATILE oldspat = curspat;
  1025.     SPAT * VOLATILE oldlspat = lastspat;
  1026.     static char *last_eval = Nullch;
  1027.     static long last_elen = 0;
  1028.     static CMD *last_root = Nullcmd;
  1029.     VOLATILE int sp = arglast[0];
  1030.     char *specfilename;
  1031.     char *tmpfilename;
  1032.     int parsing = 1;
  1033.  
  1034.     tmps_base = tmps_max;
  1035.     if (curstash != stash) {
  1036.     (void)savehptr(&curstash);
  1037.     curstash = stash;
  1038.     }
  1039.     str_set(stab_val(stabent("@",TRUE)),"");
  1040.     if (curcmd->c_line == 0)        /* don't debug debugger... */
  1041.     perldb = FALSE;
  1042.     curcmd = &compiling;
  1043.     if (optype == O_EVAL) {        /* normal eval */
  1044.     curcmd->c_filestab = fstab("(eval)");
  1045.     curcmd->c_line = 1;
  1046.     str_sset(linestr,str);
  1047.     str_cat(linestr,";\n;\n");    /* be kind to them */
  1048.     if (perldb)
  1049.         savelines(stab_xarray(curcmd->c_filestab), linestr);
  1050.     }
  1051.     else {
  1052.     if (last_root && !in_eval) {
  1053.         Safefree(last_eval);
  1054.         last_eval = Nullch;
  1055.         cmd_free(last_root);
  1056.         last_root = Nullcmd;
  1057.     }
  1058.     specfilename = str_get(str);
  1059.     str_set(linestr,"");
  1060.     if (optype == O_REQUIRE && &str_undef !=
  1061.       hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
  1062.         curcmd = oldcurcmd;
  1063.         tmps_base = oldtmps_base;
  1064.         st[++sp] = &str_yes;
  1065.         perldb = oldperldb;
  1066.         return sp;
  1067.     }
  1068.     tmpfilename = savestr(specfilename);
  1069.     if (*tmpfilename == '/' ||
  1070.         (*tmpfilename == '.' && 
  1071.         (tmpfilename[1] == '/' ||
  1072.          (tmpfilename[1] == '.' && tmpfilename[2] == '/'))))
  1073.     {
  1074.         rsfp = fopen(tmpfilename,"r");
  1075.     }
  1076.     else {
  1077.         ar = stab_array(incstab);
  1078.         for (i = 0; i <= ar->ary_fill; i++) {
  1079.         (void)sprintf(buf, "%s/%s",
  1080.           str_get(afetch(ar,i,TRUE)), specfilename);
  1081.         rsfp = fopen(buf,"r");
  1082.         if (rsfp) {
  1083.             char *s = buf;
  1084.  
  1085.             if (*s == '.' && s[1] == '/')
  1086.             s += 2;
  1087.             Safefree(tmpfilename);
  1088.             tmpfilename = savestr(s);
  1089.             break;
  1090.         }
  1091.         }
  1092.     }
  1093.     curcmd->c_filestab = fstab(tmpfilename);
  1094.     Safefree(tmpfilename);
  1095.     tmpfilename = Nullch;
  1096.     if (!rsfp) {
  1097.         curcmd = oldcurcmd;
  1098.         tmps_base = oldtmps_base;
  1099.         if (optype == O_REQUIRE) {
  1100.         sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
  1101.         if (instr(tokenbuf,".h "))
  1102.             strcat(tokenbuf," (change .h to .ph maybe?)");
  1103.         if (instr(tokenbuf,".ph "))
  1104.             strcat(tokenbuf," (did you run h2ph?)");
  1105.         fatal("%s",tokenbuf);
  1106.         }
  1107.         if (gimme != G_ARRAY)
  1108.         st[++sp] = &str_undef;
  1109.         perldb = oldperldb;
  1110.         return sp;
  1111.     }
  1112.     curcmd->c_line = 0;
  1113.     }
  1114.     in_eval++;
  1115.     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
  1116.     bufend = bufptr + linestr->str_cur;
  1117.     if (++loop_ptr >= loop_max) {
  1118.     loop_max += 128;
  1119.     Renew(loop_stack, loop_max, struct loop);
  1120.     }
  1121.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1122.     loop_stack[loop_ptr].loop_sp = sp;
  1123. #ifdef DEBUGGING
  1124.     if (debug & 4) {
  1125.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1126.     }
  1127. #endif
  1128.     eval_root = Nullcmd;
  1129.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1130.     retval = 1;
  1131.     }
  1132.     else {
  1133.     error_count = 0;
  1134.     if (rsfp) {
  1135.         retval = yyparse();
  1136.         retval |= error_count;
  1137.     }
  1138.     else if (last_root && last_elen == bufend - bufptr
  1139.       && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
  1140.         retval = 0;
  1141.         eval_root = last_root;    /* no point in reparsing */
  1142.     }
  1143.     else if (in_eval == 1 && !savecmd) {
  1144.         if (last_root) {
  1145.         Safefree(last_eval);
  1146.         last_eval = Nullch;
  1147.         cmd_free(last_root);
  1148.         }
  1149.         last_root = Nullcmd;
  1150.         last_elen = bufend - bufptr;
  1151.         last_eval = nsavestr(bufptr, last_elen);
  1152.         retval = yyparse();
  1153.         retval |= error_count;
  1154.         if (!retval)
  1155.         last_root = eval_root;
  1156.         if (!last_root) {
  1157.         Safefree(last_eval);
  1158.         last_eval = Nullch;
  1159.         }
  1160.     }
  1161.     else
  1162.         retval = yyparse();
  1163.     }
  1164.     myroot = eval_root;        /* in case cmd_exec does another eval! */
  1165.  
  1166.     if (retval || error_count) {
  1167.     st = stack->ary_array;
  1168.     sp = arglast[0];
  1169.     if (gimme != G_ARRAY)
  1170.         st[++sp] = &str_undef;
  1171.     if (parsing) {
  1172. #ifndef MANGLEDPARSE
  1173. #ifdef DEBUGGING
  1174.         if (debug & 128)
  1175.         fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
  1176. #endif
  1177.         cmd_free(eval_root);
  1178. #endif
  1179.         /*SUPPRESS 29*/ /*SUPPRESS 30*/
  1180.         if ((CMD*)eval_root == last_root)
  1181.         last_root = Nullcmd;
  1182.         eval_root = myroot = Nullcmd;
  1183.     }
  1184.     if (rsfp) {
  1185.         fclose(rsfp);
  1186.         rsfp = 0;
  1187.     }
  1188.     }
  1189.     else {
  1190.     parsing = 0;
  1191.     sp = cmd_exec(eval_root,gimme,sp);
  1192.     st = stack->ary_array;
  1193.     for (i = arglast[0] + 1; i <= sp; i++)
  1194.         st[i] = str_mortal(st[i]);
  1195.                 /* if we don't save result, free zaps it */
  1196.     if (savecmd)
  1197.         eval_root = myroot;
  1198.     else if (in_eval != 1 && myroot != last_root)
  1199.         cmd_free(myroot);
  1200.     }
  1201.  
  1202.     perldb = oldperldb;
  1203.     in_eval--;
  1204. #ifdef DEBUGGING
  1205.     if (debug & 4) {
  1206.     char *tmps = loop_stack[loop_ptr].loop_label;
  1207.     deb("(Popping label #%d %s)\n",loop_ptr,
  1208.         tmps ? tmps : "" );
  1209.     }
  1210. #endif
  1211.     loop_ptr--;
  1212.     tmps_base = oldtmps_base;
  1213.     curspat = oldspat;
  1214.     lastspat = oldlspat;
  1215.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1216.     restorelist(oldsave);
  1217.  
  1218.     if (optype != O_EVAL) {
  1219.     if (retval) {
  1220.         if (optype == O_REQUIRE)
  1221.         fatal("%s", str_get(stab_val(stabent("@",TRUE))));
  1222.     }
  1223.     else {
  1224.         curcmd = oldcurcmd;
  1225.         if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
  1226.         (void)hstore(stab_hash(incstab), specfilename,
  1227.           strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
  1228.               0 );
  1229.         }
  1230.         else if (optype == O_REQUIRE)
  1231.         fatal("%s did not return a true value", specfilename);
  1232.     }
  1233.     }
  1234.     curcmd = oldcurcmd;
  1235.     return sp;
  1236. }
  1237.  
  1238. int
  1239. do_try(cmd,gimme,arglast)
  1240. CMD *cmd;
  1241. int gimme;
  1242. int *arglast;
  1243. {
  1244.     STR **st = stack->ary_array;
  1245.  
  1246.     CMD * VOLATILE oldcurcmd = curcmd;
  1247.     VOLATILE int oldtmps_base = tmps_base;
  1248.     VOLATILE int oldsave = savestack->ary_fill;
  1249.     SPAT * VOLATILE oldspat = curspat;
  1250.     SPAT * VOLATILE oldlspat = lastspat;
  1251.     VOLATILE int sp = arglast[0];
  1252.  
  1253.     tmps_base = tmps_max;
  1254.     str_set(stab_val(stabent("@",TRUE)),"");
  1255.     in_eval++;
  1256.     if (++loop_ptr >= loop_max) {
  1257.     loop_max += 128;
  1258.     Renew(loop_stack, loop_max, struct loop);
  1259.     }
  1260.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1261.     loop_stack[loop_ptr].loop_sp = sp;
  1262. #ifdef DEBUGGING
  1263.     if (debug & 4) {
  1264.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1265.     }
  1266. #endif
  1267.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1268.     st = stack->ary_array;
  1269.     sp = arglast[0];
  1270.     if (gimme != G_ARRAY)
  1271.         st[++sp] = &str_undef;
  1272.     }
  1273.     else {
  1274.     sp = cmd_exec(cmd,gimme,sp);
  1275.     st = stack->ary_array;
  1276. /*    for (i = arglast[0] + 1; i <= sp; i++)
  1277.         st[i] = str_mortal(st[i]);  not needed, I think */
  1278.                 /* if we don't save result, free zaps it */
  1279.     }
  1280.  
  1281.     in_eval--;
  1282. #ifdef DEBUGGING
  1283.     if (debug & 4) {
  1284.     char *tmps = loop_stack[loop_ptr].loop_label;
  1285.     deb("(Popping label #%d %s)\n",loop_ptr,
  1286.         tmps ? tmps : "" );
  1287.     }
  1288. #endif
  1289.     loop_ptr--;
  1290.     tmps_base = oldtmps_base;
  1291.     curspat = oldspat;
  1292.     lastspat = oldlspat;
  1293.     curcmd = oldcurcmd;
  1294.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1295.     restorelist(oldsave);
  1296.  
  1297.     return sp;
  1298. }
  1299.  
  1300. /* This routine handles any switches that can be given during run */
  1301.  
  1302. static char *
  1303. moreswitches(s)
  1304. char *s;
  1305. {
  1306.     int numlen;
  1307.  
  1308.     switch (*s) {
  1309.     case '0':
  1310.     nrschar = scanoct(s, 4, &numlen);
  1311.     nrs = nsavestr("\n",1);
  1312.     *nrs = nrschar;
  1313.     if (nrschar > 0377) {
  1314.         nrslen = 0;
  1315.         nrs = "";
  1316.     }
  1317.     else if (!nrschar && numlen >= 2) {
  1318.         nrslen = 2;
  1319.         nrs = "\n\n";
  1320.         nrschar = '\n';
  1321.     }
  1322.     return s + numlen;
  1323.     case 'a':
  1324.     minus_a = TRUE;
  1325.     s++;
  1326.     return s;
  1327.     case 'c':
  1328.     minus_c = TRUE;
  1329.     s++;
  1330.     return s;
  1331.     case 'd':
  1332. #ifdef TAINT
  1333.     if (euid != uid || egid != gid)
  1334.         fatal("No -d allowed in setuid scripts");
  1335. #endif
  1336.     perldb = TRUE;
  1337.     s++;
  1338.     return s;
  1339.     case 'D':
  1340. #ifdef DEBUGGING
  1341. #ifdef TAINT
  1342.     if (euid != uid || egid != gid)
  1343.         fatal("No -D allowed in setuid scripts");
  1344. #endif
  1345.     debug = atoi(s+1) | 32768;
  1346. #else
  1347.     warn("Recompile perl with -DDEBUGGING to use -D switch\n");
  1348. #endif
  1349.     /*SUPPRESS 530*/
  1350.     for (s++; isDIGIT(*s); s++) ;
  1351.     return s;
  1352.     case 'i':
  1353.     inplace = savestr(s+1);
  1354.     /*SUPPRESS 530*/
  1355.     for (s = inplace; *s && !isSPACE(*s); s++) ;
  1356.     *s = '\0';
  1357.     break;
  1358.     case 'I':
  1359. #ifdef TAINT
  1360.     if (euid != uid || egid != gid)
  1361.         fatal("No -I allowed in setuid scripts");
  1362. #endif
  1363.     if (*++s) {
  1364.         (void)apush(stab_array(incstab),str_make(s,0));
  1365.     }
  1366.     else
  1367.         fatal("No space allowed after -I");
  1368.     break;
  1369.     case 'l':
  1370.     minus_l = TRUE;
  1371.     s++;
  1372.     if (isDIGIT(*s)) {
  1373.         ors = savestr("\n");
  1374.         orslen = 1;
  1375.         *ors = scanoct(s, 3 + (*s == '0'), &numlen);
  1376.         s += numlen;
  1377.     }
  1378.     else {
  1379.         ors = nsavestr(nrs,nrslen);
  1380.         orslen = nrslen;
  1381.     }
  1382.     return s;
  1383.     case 'n':
  1384.     minus_n = TRUE;
  1385.     s++;
  1386.     return s;
  1387.     case 'p':
  1388.     minus_p = TRUE;
  1389.     s++;
  1390.     return s;
  1391.     case 'u':
  1392.     do_undump = TRUE;
  1393.     s++;
  1394.     return s;
  1395.     case 'U':
  1396.     unsafe = TRUE;
  1397.     s++;
  1398.     return s;
  1399.     case 'v':
  1400.     fputs("\nThis is perl, version 4.0\n\n",stdout);
  1401.     fputs(rcsid,stdout);
  1402.     fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
  1403. #ifdef MSDOS
  1404.     fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
  1405.     stdout);
  1406. #ifdef DJGPP
  1407.     fputs("MS-DOS hack (using DJGPP) Copyright (c) 1992, Hitoshi Doi\n",
  1408.     stdout);
  1409. #endif /* DJGPP */
  1410. #ifdef OS2
  1411.         fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
  1412.         stdout);
  1413. #endif
  1414. #endif
  1415. #ifdef atarist
  1416.         fputs("atariST series port, ++jrb  bammi@cadence.com\n", stdout);
  1417. #endif
  1418.     fputs("\n\
  1419. Perl may be copied only under the terms of either the Artistic License or the\n\
  1420. GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
  1421. #ifdef MSDOS
  1422. #ifndef DJGPP
  1423.         usage(origargv[0]);
  1424. #endif /* !DJGPP */
  1425. #endif
  1426.     exit(0);
  1427.     case 'w':
  1428.     dowarn = TRUE;
  1429.     s++;
  1430.     return s;
  1431.     case ' ':
  1432.     case '\n':
  1433.     case '\t':
  1434.     break;
  1435.     default:
  1436.     fatal("Switch meaningless after -x: -%s",s);
  1437.     }
  1438.     return Nullch;
  1439. }
  1440.  
  1441. /* compliments of Tom Christiansen */
  1442.  
  1443. /* unexec() can be found in the Gnu emacs distribution */
  1444.  
  1445. void
  1446. my_unexec()
  1447. {
  1448. #ifdef UNEXEC
  1449.     int    status;
  1450.     extern int etext;
  1451.     static char dumpname[BUFSIZ];
  1452.     static char perlpath[256];
  1453.  
  1454.     sprintf (dumpname, "%s.perldump", origfilename);
  1455.     sprintf (perlpath, "%s/perl", BIN);
  1456.  
  1457.     status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
  1458.     if (status)
  1459.     fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
  1460.     exit(status);
  1461. #else
  1462. #ifdef DOSISH
  1463.     abort();    /* nothing else to do */
  1464. #else /* ! MSDOS */
  1465. #   ifndef SIGABRT
  1466. #    define SIGABRT SIGILL
  1467. #   endif
  1468. #   ifndef SIGILL
  1469. #    define SIGILL 6        /* blech */
  1470. #   endif
  1471.     kill(getpid(),SIGABRT);    /* for use with undump */
  1472. #endif /* ! MSDOS */
  1473. #endif
  1474. }
  1475.  
  1476.